home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / db2pas.zip / DB2PAS.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-11  |  4KB  |  177 lines
  1. PROGRAM translate;
  2. {Code conversion utility by Vaden House, Dec 7, 1985.
  3.  
  4. This  program is designed to take screen layouts written  in
  5. ADL (db II or III) and convert them to Turbo pascal code.  I
  6. used  Quickcode  to  produce  a number of  I/O  screens  and
  7. decided later to rewrite the program in Turbo so I thought I
  8. would  carry  my screens along with me.  The result  is  not
  9. quite so fancy as something like Screen Sculpter but is much
  10. more transparent and less likely to conflict with other code
  11. you might write,  beg,  or borrow.Please note that this only
  12. works  with  the  type of dBASE commands found  in  the  FMT
  13. files.It  will not do any fancy translation of  other  dBASE
  14. commands. That, alas is beyond my meager talent.}
  15.  
  16.  
  17.  
  18. TYPE
  19.   anystr  = STRING[255];
  20.  
  21. VAR
  22.   lineno : integer;
  23.   workline,
  24.   dbfile,
  25.   Tfile : anystr;
  26.   infile,
  27.   outfile : text;
  28.   ch      : char;
  29.   I       : integer;
  30.  
  31. PROCEDURE msg(s:anystr);
  32.     BEGIN
  33.       gotoxy(2,23);
  34.       write('':78);
  35.       gotoxy(2,23);
  36.       write(s);
  37.     END;
  38.  
  39. (*  UpcaseStr converts a string to upper case *)
  40.  
  41. function UpcaseStr(S : AnyStr) : AnyStr;
  42. var
  43.   P : Integer;
  44. begin
  45.   for P := 1 to Length(S) do
  46.     S[P] := Upcase(S[P]);
  47.   UpcaseStr := S;
  48. end;
  49.  
  50. FUNCTION Exist(FileN: AnyStr): boolean;
  51.  
  52. VAR F: FILE;
  53. BEGIN
  54.    {$I-}
  55.    assign(F,FileN);
  56.    reset(F);
  57.    {$I+}
  58.    IF IOResult<>0
  59.      THEN Exist := false
  60.      ELSE Exist := true;
  61. END;
  62.  
  63. PROCEDURE Getfilename(VAR Line: AnyStr);
  64. BEGIN
  65.   WHILE NOT exist(line) DO
  66.     BEGIN
  67.       msg('Name of DB II file (include extension) :');
  68.       Line := '';
  69.       Read(line);
  70.     END;
  71. END;
  72.  
  73. Procedure filter(line:anystr); {String delimiters must be ' '}
  74.  
  75. var
  76. i:integer;
  77.  
  78. begin
  79.       For I:=1 To Length(line) Do
  80.       begin
  81.         If (line[I]='"') Then line[I]:='''';
  82.       End;
  83.       workline:=line;
  84. end;
  85.  
  86. PROCEDURE convert(VAR line:anystr);
  87. {this cryptic piece of gobledygook does all the real work}
  88.  
  89. VAR
  90.   x,y : anystr;
  91. BEGIN
  92.   {get the x screen coordinate}
  93.   x := copy(line,3,pos(',',line)-3);
  94.   {get the y screen coordinate}
  95.   y := copy(line,pos(',',line)+1,pos('S',line)-(2+pos(',',line)));
  96.   {column 0 doesn't work so well in turbo}
  97.   IF y = '0'
  98.     THEN y := '1';
  99.   {get rid the db stuff-- delete line up to the start of the string constant}
  100.   delete(line,1,pos('SAY',line)+3);
  101.   {we only want to display string constants, send a blank line otherwise}
  102.   IF copy(line,1,1) <>''''
  103.       THEN BEGIN;
  104.            line := '';
  105.            exit;
  106.       END;
  107.   {add turbo's direct screen addressing command to the beginning of line}
  108.   insert('gotoxy(',line,1);
  109.   {reverse the x,y coordinates and add the write command}
  110.   insert(y + ',' + x + ');' + 'write(',line,8);
  111.   {add the terminating parentheses and semicolon}
  112.   line := line + ');';
  113. END;
  114.  
  115. function rvson:char;
  116. begin
  117. rvson:=' ';
  118. textcolor(0);
  119. textbackground(7);
  120. end;
  121.  
  122. function rvsoff:char;
  123. begin
  124. rvsoff:=' ';
  125. textcolor(7);
  126. textbackground(0);
  127. end;
  128.  
  129. BEGIN
  130.   clrscr;
  131.   dbfile := '';
  132.   tfile := '';
  133.  
  134.   getfilename(dbfile);
  135.   dbfile:=upcasestr(dbfile);
  136.   Tfile:=copy(dbfile,1,pos('.',dbfile))+'PAS';
  137.   if exist(Tfile) then
  138.   begin
  139.     repeat
  140.     msg('Name of Turbo file (include extension) :');
  141.     read(Tfile);
  142.     if exist(Tfile) then
  143.     begin
  144.       msg('File exists. Use another name.');
  145.       read(kbd,ch);
  146.     end;
  147.     until not exist(Tfile);
  148.   end;
  149.   Tfile:=upcasestr(Tfile);
  150.   clrscr;
  151.   gotoxy(15,12);write('Converting dBASE file ',rvson,dbfile,' ',rvsoff, 'to Turbo file ',rvson,Tfile,' ',rvsoff);
  152.  
  153.   assign(infile,dbfile);
  154.   assign(outfile,tfile);
  155.   reset(infile);
  156.   rewrite(outfile);
  157.   writeln(outfile,'PROGRAM IO;');
  158.   writeln(outfile,'BEGIN');
  159.   writeln(outfile,'   clrscr;');
  160.   lineno := 1;
  161.   WHILE NOT eof(infile) DO
  162.     BEGIN
  163.       readln(infile,workline);
  164.       filter(workline);
  165.       convert(workline);
  166.       gotoxy(30,15);writeln(' Converting line ',lineno);
  167.       if workline<>'' then
  168.       writeln(outfile,'   ',workline);
  169.       lineno := lineno+1;
  170.     END;
  171.   writeln(outfile,'END.');
  172.   close(infile);
  173.   close(outfile);
  174. msg('                         Press any key to continue....');
  175. read(kbd,ch);
  176. END.
  177.